home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-xmas.el.z / gnus-xmas.el
Encoding:
Text File  |  1998-05-21  |  27.9 KB  |  797 lines
  1. ;;; gnus-xmas.el --- Gnus functions for XEmacs
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;;; Code:
  27.  
  28. (require 'text-props)
  29. (defvar menu-bar-mode (featurep 'menubar))
  30. (require 'messagexmas)
  31.  
  32. (defgroup gnus-xmas nil
  33.   "XEmacsoid support for Gnus"
  34.   :group 'gnus)
  35.  
  36. (defcustom gnus-xmas-glyph-directory nil
  37.   "*Directory where Gnus logos and icons are located.
  38. If this variable is nil, Gnus will try to locate the directory
  39. automatically."
  40.   :type '(choice (const :tag "autodetect" nil)
  41.          directory)
  42.   :group 'gnus-xmas)
  43.  
  44. (defvar gnus-xmas-logo-color-alist
  45.   '((flame "#cc3300" "#ff2200")
  46.     (pine "#c0cc93" "#f8ffb8")
  47.     (moss "#a1cc93" "#d2ffb8")
  48.     (irish "#04cc90" "#05ff97")
  49.     (sky "#049acc" "#05deff")
  50.     (tin "#6886cc" "#82b6ff")
  51.     (velvet "#7c68cc" "#8c82ff")
  52.     (grape "#b264cc" "#cf7df")
  53.     (labia "#cc64c2" "#fd7dff")
  54.     (berry "#cc6485" "#ff7db5")
  55.     (neutral "#b4b4b4" "#878787")
  56.     (september "#bf9900" "#ffcc00"))
  57.   "Color alist used for the Gnus logo.")
  58.  
  59. (defcustom gnus-xmas-logo-color-style 'flame
  60.   "Color styles used for the Gnus logo."
  61.   :type '(choice (const flame) (const pine) (const moss)
  62.          (const irish) (const sky) (const tin)
  63.          (const velvet) (const grape) (const labia)
  64.          (const berry) (const neutral) (const september))
  65.   :group 'gnus-xmas)
  66.  
  67. (defvar gnus-xmas-logo-colors
  68.   (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
  69.   "Colors used for the Gnus logo.")
  70.  
  71. (defcustom gnus-article-x-face-command
  72.   (if (or (featurep 'xface)
  73.       (featurep 'xpm))
  74.       'gnus-xmas-article-display-xface
  75.     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")
  76.   "String or function to be executed to display an X-Face header.
  77. If it is a string, the command will be executed in a sub-shell
  78. asynchronously.     The compressed face will be piped to this command."
  79.   :type '(choice string function))
  80.  
  81. ;;; Internal variables.
  82.  
  83. ;; Don't warn about these undefined variables.
  84.  
  85. (defvar gnus-group-mode-hook)
  86. (defvar gnus-summary-mode-hook)
  87. (defvar gnus-article-mode-hook)
  88.  
  89. ;;defined in gnus.el
  90. (defvar gnus-active-hashtb)
  91. (defvar gnus-article-buffer)
  92. (defvar gnus-auto-center-summary)
  93. (defvar gnus-buffer-list)
  94. (defvar gnus-current-headers)
  95. (defvar gnus-level-killed)
  96. (defvar gnus-level-zombie)
  97. (defvar gnus-newsgroup-bookmarks)
  98. (defvar gnus-newsgroup-dependencies)
  99. (defvar gnus-newsgroup-selected-overlay)
  100. (defvar gnus-newsrc-hashtb)
  101. (defvar gnus-read-mark)
  102. (defvar gnus-refer-article-method)
  103. (defvar gnus-reffed-article-number)
  104. (defvar gnus-unread-mark)
  105. (defvar gnus-version)
  106. (defvar gnus-view-pseudos)
  107. (defvar gnus-view-pseudos-separately)
  108. (defvar gnus-visual)
  109. (defvar gnus-zombie-list)
  110. ;;defined in gnus-msg.el
  111. (defvar gnus-article-copy)
  112. (defvar gnus-check-before-posting)
  113. ;;defined in gnus-vis.el
  114. (defvar gnus-article-button-face)
  115. (defvar gnus-article-mouse-face)
  116. (defvar gnus-summary-selected-face)
  117. (defvar gnus-group-reading-menu)
  118. (defvar gnus-group-group-menu)
  119. (defvar gnus-group-misc-menu)
  120. (defvar gnus-summary-article-menu)
  121. (defvar gnus-summary-thread-menu)
  122. (defvar gnus-summary-misc-menu)
  123. (defvar gnus-summary-post-menu)
  124. (defvar gnus-summary-kill-menu)
  125. (defvar gnus-article-article-menu)
  126. (defvar gnus-article-treatment-menu)
  127. (defvar gnus-mouse-2)
  128. (defvar standard-display-table)
  129. (defvar gnus-tree-minimize-window)
  130.  
  131. (defun gnus-xmas-set-text-properties (start end props &optional buffer)
  132.   "You should NEVER use this function.  It is ideologically blasphemous.
  133. It is provided only to ease porting of broken FSF Emacs programs."
  134.   (if (stringp buffer)
  135.       nil
  136.     (map-extents (lambda (extent ignored)
  137.                    (remove-text-properties
  138.                     start end
  139.                     (list (extent-property extent 'text-prop) nil)
  140.                     buffer)
  141.            nil)
  142.                  buffer start end nil nil 'text-prop)
  143.     (gnus-add-text-properties start end props buffer)))
  144.  
  145. (defun gnus-xmas-highlight-selected-summary ()
  146.   ;; Highlight selected article in summary buffer
  147.   (when gnus-summary-selected-face
  148.     (when gnus-newsgroup-selected-overlay
  149.       (delete-extent gnus-newsgroup-selected-overlay))
  150.     (setq gnus-newsgroup-selected-overlay
  151.       (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
  152.     (set-extent-face gnus-newsgroup-selected-overlay
  153.              gnus-summary-selected-face)))
  154.  
  155. (defcustom gnus-xmas-force-redisplay nil
  156.   "If non-nil, force a redisplay before recentering the summary buffer.
  157. This is ugly, but it works around a bug in `window-displayed-height'."
  158.   :type 'boolean
  159.   :group 'gnus-xmas)
  160.  
  161. (defun gnus-xmas-switch-horizontal-scrollbar-off ()
  162.   (when (featurep 'scrollbar)
  163.     (set-specifier scrollbar-height (cons (current-buffer) 0))))
  164.  
  165. (defun gnus-xmas-summary-recenter ()
  166.   "\"Center\" point in the summary window.
  167. If `gnus-auto-center-summary' is nil, or the article buffer isn't
  168. displayed, no centering will be performed."
  169.   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
  170.   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
  171.   ;; Force redisplay to get properly computed window height.
  172.   (when gnus-xmas-force-redisplay
  173.     (sit-for 0))
  174.   (when gnus-auto-center-summary
  175.     (let* ((height (if (fboundp 'window-displayed-height)
  176.                (window-displayed-height)
  177.              (- (window-height) 2)))
  178.        (top (cond ((< height 4) 0)
  179.               ((< height 7) 1)
  180.               (t 2)))
  181.        (bottom (save-excursion (goto-char (point-max))
  182.                    (forward-line (- height))
  183.                    (point)))
  184.        (window (get-buffer-window (current-buffer))))
  185.       (when (get-buffer-window gnus-article-buffer)
  186.     ;; Only do recentering when the article buffer is displayed,
  187.     ;; Set the window start to either `bottom', which is the biggest
  188.     ;; possible valid number, or the second line from the top,
  189.     ;; whichever is the least.
  190.     (set-window-start
  191.      window (min bottom (save-excursion (forward-line (- top)) (point)))))
  192.       ;; Do horizontal recentering while we're at it.
  193.       (when (and (get-buffer-window (current-buffer) t)
  194.          (not (eq gnus-auto-center-summary 'vertical)))
  195.     (let ((selected (selected-window)))
  196.       (select-window (get-buffer-window (current-buffer) t))
  197.       (gnus-summary-position-point)
  198.       (gnus-horizontal-recenter)
  199.       (select-window selected))))))
  200.  
  201. (defun gnus-xmas-summary-set-display-table ()
  202.   ;; Setup the display table -- like `gnus-summary-setup-display-table',
  203.   ;; but done in an XEmacsish way.
  204.   (let ((table (make-display-table))
  205.     (i 32))
  206.     ;; Nix out all the control chars...
  207.     (while (>= (setq i (1- i)) 0)
  208.       (aset table i [??]))
  209.     ;; ... but not newline and cr, of course.  (cr is necessary for the
  210.     ;; selective display).
  211.     (aset table ?\n nil)
  212.     (aset table ?\r nil)
  213.     ;; We nix out any glyphs over 126 below ctl-arrow.
  214.     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
  215.       (while (>= (setq i (1- i)) 127)
  216.     (unless (aref table i)
  217.       (aset table i [??]))))
  218.     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
  219.     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
  220.  
  221. (defun gnus-xmas-add-text-properties (start end props &optional object)
  222.   (add-text-properties start end props object)
  223.   (put-text-property start end 'start-closed nil object))
  224.  
  225. (defun gnus-xmas-put-text-property (start end prop value &optional object)
  226.   (put-text-property start end prop value object)
  227.   (put-text-property start end 'start-closed nil object))
  228.  
  229. (defun gnus-xmas-extent-start-open (point)
  230.   (map-extents (lambda (extent arg)
  231.          (set-extent-property extent 'start-open t))
  232.            nil point (min (1+ (point)) (point-max))))
  233.  
  234. (defun gnus-xmas-article-push-button (event)
  235.   "Check text under the mouse pointer for a callback function.
  236. If the text under the mouse pointer has a `gnus-callback' property,
  237. call it with the value of the `gnus-data' text property."
  238.   (interactive "e")
  239.   (set-buffer (window-buffer (event-window event)))
  240.   (let* ((pos (event-closest-point event))
  241.      (data (get-text-property pos 'gnus-data))
  242.      (fun (get-text-property pos 'gnus-callback)))
  243.     (when fun
  244.       (funcall fun data))))
  245.  
  246. (defun gnus-xmas-move-overlay (extent start end &optional buffer)
  247.   (set-extent-endpoints extent start end))
  248.  
  249. ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
  250. (defun gnus-xmas-article-add-button (from to fun &optional data)
  251.   "Create a button between FROM and TO with callback FUN and data DATA."
  252.   (when gnus-article-button-face
  253.     (gnus-overlay-put (gnus-make-overlay from to)
  254.               'face gnus-article-button-face))
  255.   (gnus-add-text-properties
  256.    from to
  257.    (nconc
  258.     (and gnus-article-mouse-face
  259.      (list 'mouse-face gnus-article-mouse-face))
  260.     (list 'gnus-callback fun)
  261.     (and data (list 'gnus-data data))
  262.     (list 'highlight t))))
  263.  
  264. (defun gnus-xmas-window-top-edge (&optional window)
  265.   (nth 1 (window-pixel-edges window)))
  266.  
  267. (defun gnus-xmas-tree-minimize ()
  268.   (when (and gnus-tree-minimize-window
  269.          (not (one-window-p)))
  270.     (let* ((window-min-height 2)
  271.        (height (1+ (count-lines (point-min) (point-max))))
  272.        (min (max (1- window-min-height) height))
  273.        (tot (if (numberp gnus-tree-minimize-window)
  274.             (min gnus-tree-minimize-window min)
  275.           min))
  276.        (win (get-buffer-window (current-buffer)))
  277.        (wh (and win (1- (window-height win)))))
  278.       (when (and win
  279.          (not (eq tot wh)))
  280.     (let ((selected (selected-window)))
  281.       (select-window win)
  282.       (enlarge-window (- tot wh))
  283.       (select-window selected))))))
  284.  
  285. ;; Select the lowest window on the frame.
  286. (defun gnus-xmas-appt-select-lowest-window ()
  287.   (let* ((lowest-window (selected-window))
  288.      (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
  289.          (last-window (previous-window))
  290.          (window-search t))
  291.     (while window-search
  292.       (let* ((this-window (next-window))
  293.              (next-bottom-edge (car (cdr (cdr (cdr
  294.                                                (window-pixel-edges
  295.                         this-window)))))))
  296.         (when (< bottom-edge next-bottom-edge)
  297.       (setq bottom-edge next-bottom-edge)
  298.       (setq lowest-window this-window))
  299.  
  300.         (select-window this-window)
  301.         (when (eq last-window this-window)
  302.       (select-window lowest-window)
  303.       (setq window-search nil))))))
  304.  
  305. (defmacro gnus-xmas-menu-add (type &rest menus)
  306.   `(gnus-xmas-menu-add-1 ',type ',menus))
  307. (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
  308.  
  309. (defun gnus-xmas-menu-add-1 (type menus)
  310.   (when (and menu-bar-mode
  311.          (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
  312.     (while menus
  313.       (easy-menu-add (symbol-value (pop menus))))))
  314.  
  315. (defun gnus-xmas-group-menu-add ()
  316.   (gnus-xmas-menu-add group
  317.     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
  318.  
  319. (defun gnus-xmas-summary-menu-add ()
  320.   (gnus-xmas-menu-add summary
  321.     gnus-summary-misc-menu gnus-summary-kill-menu
  322.     gnus-summary-article-menu gnus-summary-thread-menu
  323.     gnus-summary-post-menu ))
  324.  
  325. (defun gnus-xmas-article-menu-add ()
  326.   (gnus-xmas-menu-add article
  327.     gnus-article-article-menu gnus-article-treatment-menu))
  328.  
  329. (defun gnus-xmas-score-menu-add ()
  330.   (gnus-xmas-menu-add score
  331.     gnus-score-menu))
  332.  
  333. (defun gnus-xmas-pick-menu-add ()
  334.   (gnus-xmas-menu-add pick
  335.     gnus-pick-menu))
  336.  
  337. (defun gnus-xmas-topic-menu-add ()
  338.   (gnus-xmas-menu-add topic
  339.     gnus-topic-menu))
  340.  
  341. (defun gnus-xmas-binary-menu-add ()
  342.   (gnus-xmas-menu-add binary
  343.     gnus-binary-menu))
  344.  
  345. (defun gnus-xmas-tree-menu-add ()
  346.   (gnus-xmas-menu-add tree
  347.     gnus-tree-menu))
  348.  
  349. (defun gnus-xmas-server-menu-add ()
  350.   (gnus-xmas-menu-add menu
  351.     gnus-server-server-menu gnus-server-connections-menu))
  352.  
  353. (defun gnus-xmas-browse-menu-add ()
  354.   (gnus-xmas-menu-add browse
  355.     gnus-browse-menu))
  356.  
  357. (defun gnus-xmas-grouplens-menu-add ()
  358.   (gnus-xmas-menu-add grouplens
  359.     gnus-grouplens-menu))
  360.  
  361. (defun gnus-xmas-read-event-char ()
  362.   "Get the next event."
  363.   (let ((event (next-command-event)))
  364.     (sit-for 0)
  365.     ;; We junk all non-key events.  Is this naughty?
  366.     (while (not (or (key-press-event-p event)
  367.             (button-press-event-p event)))
  368.       (dispatch-event event)
  369.       (setq event (next-command-event)))
  370.     (cons (and (key-press-event-p event)
  371.            (event-to-character event))
  372.       event)))
  373.  
  374. (defun gnus-xmas-seconds-since-epoch (date)
  375.   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
  376.   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
  377.             (timezone-parse-date date)))
  378.      (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
  379.             (timezone-parse-time
  380.              (aref (timezone-parse-date date) 3))))
  381.      (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
  382.             (timezone-parse-date "Jan 1 12:00:00 1970")))
  383.      (tday (- (timezone-absolute-from-gregorian
  384.            (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
  385.           (timezone-absolute-from-gregorian
  386.            (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
  387.     (+ (nth 2 ttime)
  388.        (* (nth 1 ttime) 60)
  389.        (* (float (nth 0 ttime)) 60 60)
  390.        (* (float tday) 60 60 24))))
  391.  
  392. (defun gnus-xmas-define ()
  393.   (setq gnus-mouse-2 [button2])
  394.  
  395.   (unless (memq 'underline (face-list))
  396.     (and (fboundp 'make-face)
  397.      (funcall (intern "make-face") 'underline)))
  398.   ;; Must avoid calling set-face-underline-p directly, because it
  399.   ;; is a defsubst in emacs19, and will make the .elc files non
  400.   ;; portable!
  401.   (unless (face-differs-from-default-p 'underline)
  402.     (funcall (intern "set-face-underline-p") 'underline t))
  403.  
  404.   (cond
  405.    ((fboundp 'char-or-char-int-p)
  406.     ;; Handle both types of marks for XEmacs-20.x.
  407.     (fset 'gnus-characterp 'char-or-char-int-p))
  408.    ;; V19 of XEmacs, probably.
  409.    (t
  410.     (fset 'gnus-characterp 'characterp)))
  411.  
  412.   (fset 'gnus-make-overlay 'make-extent)
  413.   (fset 'gnus-overlay-put 'set-extent-property)
  414.   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
  415.   (fset 'gnus-overlay-end 'extent-end-position)
  416.   (fset 'gnus-extent-detached-p 'extent-detached-p)
  417.   (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
  418.   (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
  419.  
  420.   (require 'text-props)
  421.   (if (and (<= emacs-major-version 19)
  422.         (< emacs-minor-version 14))
  423.       (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
  424.  
  425.   (when (fboundp 'turn-off-scroll-in-place)
  426.     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
  427.  
  428.   (unless (boundp 'standard-display-table)
  429.     (setq standard-display-table nil))
  430.  
  431.   (defvar gnus-mouse-face-prop 'highlight)
  432.  
  433.   (unless (fboundp 'encode-time)
  434.     (defun encode-time (sec minute hour day month year &optional zone)
  435.       (let ((seconds
  436.          (gnus-xmas-seconds-since-epoch
  437.           (timezone-make-arpa-date
  438.            year month day (timezone-make-time-string hour minute sec)
  439.            zone))))
  440.     (list (floor (/ seconds (expt 2 16)))
  441.           (round (mod seconds (expt 2 16)))))))
  442.  
  443.   (defun gnus-byte-code (func)
  444.     "Return a form that can be `eval'ed based on FUNC."
  445.     (let ((fval (symbol-function func)))
  446.       (if (compiled-function-p fval)
  447.       (list 'funcall fval)
  448.     (cons 'progn (cdr (cdr fval))))))
  449.  
  450.   (fset 'gnus-x-color-values
  451.     (if (fboundp 'x-color-values)
  452.         'x-color-values
  453.       (lambda (color)
  454.         (color-instance-rgb-components
  455.          (make-color-instance color))))))
  456.  
  457. (defun gnus-xmas-redefine ()
  458.   "Redefine lots of Gnus functions for XEmacs."
  459.   (fset 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)
  460.   (fset 'gnus-visual-turn-off-edit-menu 'identity)
  461.   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
  462.   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
  463.   (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
  464.   (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
  465.   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
  466.   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
  467.   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
  468.   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
  469.   (fset 'gnus-appt-select-lowest-window
  470.     'gnus-xmas-appt-select-lowest-window)
  471.   (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
  472.   (fset 'gnus-character-to-event 'character-to-event)
  473.   (fset 'gnus-mode-line-buffer-identification
  474.     'gnus-xmas-mode-line-buffer-identification)
  475.   (fset 'gnus-key-press-event-p 'key-press-event-p)
  476.   (fset 'gnus-region-active-p 'region-active-p)
  477.  
  478.   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
  479.   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
  480.   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
  481.   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
  482.  
  483.   (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
  484.   (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)
  485.   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
  486.   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
  487.   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
  488.   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
  489.   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
  490.  
  491.   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
  492.   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
  493.  
  494.   (add-hook 'gnus-summary-mode-hook
  495.         'gnus-xmas-switch-horizontal-scrollbar-off)
  496.   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off))
  497.  
  498.  
  499. ;;; XEmacs logo and toolbar.
  500.  
  501. (defun gnus-xmas-group-startup-message (&optional x y)
  502.   "Insert startup message in current buffer."
  503.   ;; Insert the message.
  504.   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
  505.   (erase-buffer)
  506.   (cond
  507.    ((and (console-on-window-system-p)
  508.      (or (featurep 'xpm)
  509.          (featurep 'xbm)))
  510.     (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
  511.        (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
  512.        (glyph (make-glyph
  513.            (cond ((featurep 'xpm)
  514.               `[xpm
  515.                 :file ,logo-xpm
  516.                 :color-symbols
  517.                 (("thing" . ,(car gnus-xmas-logo-colors))
  518.                  ("shadow" . ,(cadr gnus-xmas-logo-colors))
  519.                  ("background" . ,(face-background 'default)))])
  520.              ((featurep 'xbm)
  521.               `[xbm :file ,logo-xbm])
  522.              (t [nothing])))))
  523.       (insert " ")
  524.       (set-extent-begin-glyph (make-extent (point) (point)) glyph)
  525.       (goto-char (point-min))
  526.       (while (not (eobp))
  527.     (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
  528.                  ?\ ))
  529.     (forward-line 1)))
  530.     (goto-char (point-min))
  531.     (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
  532.        (wheight (window-height))
  533.        (rest (- wheight pheight)))
  534.       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
  535.    (t
  536.     (insert
  537.      (format "              %s
  538.           _    ___ _             _
  539.           _ ___ __ ___  __    _ ___
  540.           __   _     ___    __  ___
  541.               _           ___     _
  542.              _  _ __             _
  543.              ___   __            _
  544.                    __           _
  545.                     _      _   _
  546.                    _      _    _
  547.                       _  _    _
  548.                   __  ___
  549.                  _   _ _     _
  550.                 _   _
  551.               _    _
  552.              _    _
  553.             _
  554.           __
  555.  
  556. "
  557.          ""))
  558.     ;; And then hack it.
  559.     (gnus-indent-rigidly (point-min) (point-max)
  560.              (/ (max (- (window-width) (or x 46)) 0) 2))
  561.     (goto-char (point-min))
  562.     (forward-line 1)
  563.     (let* ((pheight (count-lines (point-min) (point-max)))
  564.        (wheight (window-height))
  565.        (rest (- wheight pheight)))
  566.       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
  567.     ;; Paint it.
  568.     (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
  569.   (setq modeline-buffer-identification
  570.     (list (concat gnus-version ": *Group*")))
  571.   (set-buffer-modified-p t))
  572.  
  573.  
  574. ;;; The toolbar.
  575.  
  576. (defcustom gnus-use-toolbar (if (featurep 'toolbar)
  577.                 'default-toolbar
  578.                   nil)
  579.   "*If nil, do not use a toolbar.
  580. If it is non-nil, it must be a toolbar.  The five legal values are
  581. `default-toolbar', `top-toolbar', `bottom-toolbar',
  582. `right-toolbar', and `left-toolbar'."
  583.   :type '(choice (const default-toolbar)
  584.          (const top-toolbar) (const bottom-toolbar)
  585.          (const left-toolbar) (const right-toolbar)
  586.          (const :tag "no toolbar" nil))
  587.   :group 'gnus-xmas)
  588.  
  589. (defvar gnus-group-toolbar
  590.   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
  591.     [gnus-group-get-new-news-this-group
  592.      gnus-group-get-new-news-this-group t "Get new news in this group"]
  593.     [gnus-group-catchup-current
  594.      gnus-group-catchup-current t "Catchup group"]
  595.     [gnus-group-describe-group
  596.      gnus-group-describe-group t "Describe group"]
  597.     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
  598.     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
  599.     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
  600.     [gnus-group-exit gnus-group-exit t "Exit Gnus"]
  601.     )
  602.   "The group buffer toolbar.")
  603.  
  604. (defvar gnus-summary-toolbar
  605.   '([gnus-summary-prev-unread
  606.      gnus-summary-prev-page-or-article t "Page up"]
  607.     [gnus-summary-next-unread
  608.      gnus-summary-next-page t "Page down"]
  609.     [gnus-summary-post-news
  610.      gnus-summary-post-news t "Post an article"]
  611.     [gnus-summary-followup-with-original
  612.      gnus-summary-followup-with-original t
  613.      "Post a followup and yank the original"]
  614.     [gnus-summary-followup
  615.      gnus-summary-followup t "Post a followup"]
  616.     [gnus-summary-reply-with-original
  617.      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
  618.     [gnus-summary-reply
  619.      gnus-summary-reply t "Mail a reply"]
  620.     [gnus-summary-caesar-message
  621.      gnus-summary-caesar-message t "Rot 13"]
  622.     [gnus-uu-decode-uu
  623.      gnus-uu-decode-uu t "Decode uuencoded articles"]
  624.     [gnus-summary-save-article-file
  625.      gnus-summary-save-article-file t "Save article in file"]
  626.     [gnus-summary-save-article
  627.      gnus-summary-save-article t "Save article"]
  628.     [gnus-uu-post-news
  629.      gnus-uu-post-news t "Post a uuencoded article"]
  630.     [gnus-summary-cancel-article
  631.      gnus-summary-cancel-article t "Cancel article"]
  632.     [gnus-summary-catchup
  633.      gnus-summary-catchup t "Catchup"]
  634.     [gnus-summary-catchup-and-exit
  635.      gnus-summary-catchup-and-exit t "Catchup and exit"]
  636.     [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
  637.     )
  638.   "The summary buffer toolbar.")
  639.  
  640. (defvar gnus-summary-mail-toolbar
  641.   '(
  642.     [gnus-summary-prev-unread
  643.      gnus-summary-prev-unread-article t "Prev unread article"]
  644.     [gnus-summary-next-unread
  645.      gnus-summary-next-unread-article t "Next unread article"]
  646.     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
  647. ;    [gnus-summary-mail-get gnus-mail-get t "Message get"]
  648.     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
  649.     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
  650.     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
  651. ;    [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
  652.     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
  653. ;    [gnus-summary-mail-spell gnus-mail-spell t "Spell"]
  654. ;    [gnus-summary-mail-help gnus-mail-help  t "Message help"]
  655.     [gnus-summary-caesar-message
  656.      gnus-summary-caesar-message t "Rot 13"]
  657.     [gnus-uu-decode-uu
  658.      gnus-uu-decode-uu t "Decode uuencoded articles"]
  659.     [gnus-summary-save-article-file
  660.      gnus-summary-save-article-file t "Save article in file"]
  661.     [gnus-summary-save-article
  662.      gnus-summary-save-article t "Save article"]
  663.     [gnus-summary-catchup
  664.      gnus-summary-catchup t "Catchup"]
  665.     [gnus-summary-catchup-and-exit
  666.      gnus-summary-catchup-and-exit t "Catchup and exit"]
  667.     [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
  668.     )
  669.   "The summary buffer mail toolbar.")
  670.  
  671. (defun gnus-xmas-setup-group-toolbar ()
  672.   (and gnus-use-toolbar
  673.        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
  674.        (set-specifier (symbol-value gnus-use-toolbar)
  675.               (cons (current-buffer) gnus-group-toolbar))))
  676.  
  677. (defun gnus-xmas-setup-summary-toolbar ()
  678.   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
  679.          gnus-summary-toolbar gnus-summary-mail-toolbar)))
  680.     (and gnus-use-toolbar
  681.      (message-xmas-setup-toolbar bar nil "gnus")
  682.      (set-specifier (symbol-value gnus-use-toolbar)
  683.             (cons (current-buffer) bar)))))
  684.  
  685. (defun gnus-xmas-mail-strip-quoted-names (address)
  686.   "Protect mail-strip-quoted-names from NIL input.
  687. XEmacs compatibility workaround."
  688.   (if (null address)
  689.       nil
  690.     (mail-strip-quoted-names address)))
  691.  
  692. (defun gnus-xmas-call-region (command &rest args)
  693.   (apply
  694.    'call-process-region (point-min) (point-max) command t '(t nil) nil
  695.    args))
  696.  
  697. (defface gnus-x-face '((t (:foreground "black" :background "white")))
  698.   "Face to show X face"
  699.   :group 'gnus-xmas)
  700.  
  701. (defun gnus-xmas-article-display-xface (beg end)
  702.   "Display any XFace headers in the current article."
  703.   (save-excursion
  704.     (let ((xface-glyph
  705.        (cond ((featurep 'xface)
  706.           (make-glyph (vector 'xface :data
  707.                       (concat "X-Face: "
  708.                           (buffer-substring beg end)))))
  709.          ((featurep 'xpm)
  710.           (let ((cur (current-buffer)))
  711.             (save-excursion
  712.               (gnus-set-work-buffer)
  713.               (insert (format "%s" (buffer-substring beg end cur)))
  714.               (gnus-xmas-call-region "uncompface")
  715.               (goto-char (point-min))
  716.               (insert "/* Width=48, Height=48 */\n")
  717.               (gnus-xmas-call-region "icontopbm")
  718.               (gnus-xmas-call-region "ppmtoxpm")
  719.               (make-glyph
  720.                (vector 'xpm :data (buffer-string))))))
  721.          (t
  722.           (make-glyph [nothing])))))
  723.       (set-glyph-face xface-glyph 'gnus-x-face)
  724.       (goto-char (point-min))
  725.       (re-search-forward "^From:" nil t)
  726.       (set-extent-begin-glyph
  727.        (make-extent (point) (1+ (point))) xface-glyph))))
  728.  
  729. ;;(defvar gnus-xmas-pointer-glyph
  730. ;;  (progn
  731. ;;    (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory
  732. ;;                                     "gnus"))
  733. ;;    (let ((file-xpm (expand-file-name "gnus-pointer.xpm"
  734. ;;                      gnus-xmas-glyph-directory))
  735. ;;      (file-xbm (expand-file-name "gnus-pointer.xbm"
  736. ;;                      gnus-xmas-glyph-directory)))
  737. ;;      (make-pointer-glyph
  738. ;;       (list (vector 'xpm ':file file-xpm)
  739. ;;         (vector 'xbm ':file file-xbm))))))
  740.  
  741. (defvar gnus-xmas-modeline-left-extent
  742.   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
  743. ;    (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
  744.     ext))
  745.  
  746. (defvar gnus-xmas-modeline-right-extent
  747.   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
  748. ;    (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
  749.     ext))
  750.  
  751. (defvar gnus-xmas-modeline-glyph
  752.   (progn
  753.     (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
  754.     (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
  755.                     gnus-xmas-glyph-directory))
  756.        (file-xbm (expand-file-name "gnus-pointer.xbm"
  757.                     gnus-xmas-glyph-directory))
  758.        (glyph (make-glyph
  759.            ;; Gag gag gag.
  760.            (cond ((featurep 'xpm)
  761.               ;; Let's try a nifty XPM
  762.               `[xpm :file ,file-xpm])
  763.              ((featurep 'xbm)
  764.               ;; Then a not-so-nifty XBM
  765.               [xbm :file ,file-xbm])
  766.              ;; Then the simple string
  767.              (t [string :data "Gnus:"])))))
  768.       (set-glyph-face glyph 'modeline-buffer-id)
  769.       glyph)))
  770.  
  771. (defun gnus-xmas-mode-line-buffer-identification (line)
  772.   (let ((line (car line))
  773.     chop)
  774.     (cond
  775.      ;; This is some weird type of id.
  776.      ((not (stringp line))
  777.       (list line))
  778.      ;; This is non-standard, so we just pass it through.
  779.      ((not (string-match "^Gnus:" line))
  780.       (list line))
  781.      ;; We have a standard line, so we colorize and glyphize it a bit.
  782.      (t
  783.       (setq chop (match-end 0))
  784.       (list
  785.        (if gnus-xmas-modeline-glyph
  786.        (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
  787.      (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
  788.        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
  789.  
  790. (defun gnus-xmas-splash ()
  791.   (when (eq (device-type) 'x)
  792.     (gnus-splash)))
  793.  
  794. (provide 'gnus-xmas)
  795.  
  796. ;;; gnus-xmas.el ends here
  797.